Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/TCPExample/PNL Libraries/MyMemory.p

Text File | 1997-06-06 | 10KB | 383 lines

unit MyMemory;

interface

    uses
        Types,
        MyAssertions;

    const
        trash_byte = $E5; { odd, big, negative, easily recognizable }

{ WARNING: MTrash et al only do anything in debugging mode! }

{$ifc not do_debug}
{$definec MTrash(p,s)}
{$definec MTrashPtr(p)}
{$definec MTrashHandle(h)}
{$elsec}
{$definec MTrash(p,s) MFill(p,s,trash_byte)}
{$definec MTrashPtr(p) MFill(p,GetPtrSize(p),trash_byte)}
{$definec MTrashHandle(h) MFill(h^,MGetHandleSize(h),trash_byte)}
{$endc}

    function MNewPtr ( var p: univ Ptr; size: longint ): OSErr;
    function MNewHandle ( var data: univ Handle; size: longint ): OSErr;
    function MSetPtrSize ( p: univ Ptr; size: longint ): OSErr;
    function MSetHandleSize ( data: univ Handle; size: longint ): OSErr;
    function MGrowHandleSize ( data: univ Handle; size: longint ): OSErr;
    procedure MShrinkHandleSize( data: univ Handle; size: longint );
    procedure MDisposePtr ( var p: univ Ptr );
    procedure MDisposeHandle ( var data: univ Handle );
    function MMungerFindString( data: Handle; offset: longint; const s: string ): longint;
    function MMungerFind( data: Handle; offset: longint; ptr1: univ Ptr; len1: longint ): longint;
    function MMungerInsert( data: Handle; offset: longint; ptr2: univ Ptr; len2: longint ): OSErr;
    function MMungerInsertString( data: Handle; offset: longint; const s: string ): OSErr;
    procedure MMungerDelete( data: Handle; offset: longint; len1: longint );
    function MAppendToHandle( data: univ Handle; p: univ Ptr; len: longint ): OSErr;
    procedure MZero ( p: univ Ptr; size: longint );
    procedure MFill ( p: univ Ptr; size: longint; val: integer );
    procedure MFillLong ( p: univ Ptr; size: longint; val: longint );
{ Ptr and size must be long alligned }
    procedure LockHigh ( data: univ Handle );
    procedure HLockState ( data: univ Handle; var state: SignedByte );
    procedure HUnlockState ( data: univ Handle; var state: SignedByte );
    procedure HRestoreState(hhhh: univ Handle; state: SignedByte);
    function MGetHandleSize( data: univ Handle ): longint;
    function MGetPtrSize( data: univ Ptr ): longint;

    procedure MHLock( data: univ Handle );
    procedure MHUnlock( data: univ Handle );
    procedure MHPurge( data: univ Handle );
    procedure MHNoPurge( data: univ Handle );

    function CheckPointer ( p: Ptr ): boolean;
    function CheckPtr ( p: Ptr ): boolean;
    function CheckHandle ( data: Handle ): boolean;

implementation

    uses
        Memory, TextUtils,
        MyLowLevel;

    function CheckPointer ( p: Ptr ): boolean;
    begin
        Assert( p <> nil );
        CheckPointer := p <> nil;
    end;

    function CheckPtr ( p: Ptr ): boolean;
    begin
        Assert( (p <> nil) & (GetPtrSize( p ) >= 0) & (MemError = noErr) );
        CheckPtr := p <> nil;
    end;

    function CheckHandle ( data: Handle ): boolean;
    begin
        Assert( (data <> nil) & (GetHandleSize( data ) >= 0) & (MemError = noErr) );
        CheckHandle := data <> nil;
    end;

    function MNewPtr ( var p: univ Ptr; size: longint ): OSErr;
        var
            err: OSErr;
    begin
        Assert( size >= 0 );
        p := NewPtr(size);
        err := MemError;
        if (err = noErr) then begin
            MTrashPtr( p );
        end;
        MNewPtr := err;
    end;

    function MNewHandle ( var data: univ Handle; size: longint ): OSErr;
        var
            err: OSErr;
    begin
        Assert( size >= 0 );
        data := NewHandle(size);
        err := MemError;
        if (err = noErr) then begin
            MTrashHandle( data );
        end;
        MNewHandle := err;
    end;

    function MSetPtrSize ( p: univ Ptr; size: longint ): OSErr;
{$ifc do_debug}
        var
            oldsize: longint;
{$endc}
    begin
{$ifc do_debug}
        Assert( p <> nil );
        Assert( size >= 0 );
        oldsize := GetPtrSize( p );
        if oldsize < size then begin
            SetPtrSize( p, size );
            if MemError = noErr then begin
                MTrash( AddPtrLong( p, oldsize ), size - oldsize );
            end;
        end else if oldsize > size then begin
            MTrash( AddPtrLong( p, size ), oldsize - size );
        end;
{$endc}
        if CheckPtr( p ) then begin
            SetPtrSize( p, size );
            MSetPtrSize := MemError;
        end else begin
            MSetPtrSize := -1;
        end;
    end;

    function MSetHandleSize ( data: univ Handle; size: longint ): OSErr;
{$ifc do_debug}
        var
            oldsize: longint;
{$endc}
    begin
{$ifc do_debug}
        Assert( data <> nil );
        Assert( size >= 0 );
        oldsize := MGetHandleSize( data );
        Assert( MemError = noErr );
        if oldsize < size then begin
            SetHandleSize( data, size );
            if MemError = noErr then begin
                MTrash( AddPtrLong( data^, oldsize ), size - oldsize );
            end;
        end else if oldsize > size then begin
            MTrash( AddPtrLong( data^, size ), oldsize - size );
        end;
{$endc}
        if CheckHandle( data ) then begin
            SetHandleSize( data, size );
            MSetHandleSize := MemError;
        end else begin
            MSetHandleSize := -1;
        end;
    end;

    function MGrowHandleSize ( data: univ Handle; size: longint ): OSErr;
{$ifc do_debug}
        var
            oldsize: longint;
{$endc}
    begin
{$ifc do_debug}
        Assert( data <> nil );
        Assert( size >= 0 );
        oldsize := MGetHandleSize( data );
        Assert( MemError = noErr );
        Assert( size >= oldsize );
{$endc}
        MGrowHandleSize := MSetHandleSize( data, size );
    end;

    procedure MShrinkHandleSize( data: univ Handle; size: longint );
{$ifc do_debug}
        var
            oldsize: longint;
{$endc}
        var
            junk: OSErr;
    begin
{$ifc do_debug}
        Assert( data <> nil );
        Assert( size >= 0 );
        oldsize := MGetHandleSize( data );
        Assert( MemError = noErr );
        Assert( size <= oldsize );
{$endc}
        junk := MSetHandleSize( data, size );
        Assert( junk = noErr );
    end;

    procedure MDisposePtr ( var p: univ Ptr );
    begin
        if (p <> nil) & CheckPtr( p ) then begin
            MTrashPtr( p );
            DisposePtr(p);
            p := nil;
        end;
    end;

    procedure MDisposeHandle ( var data: univ Handle );
    begin
        if (data <> nil) & CheckHandle( data ) then begin
            MTrashHandle( data );
            DisposeHandle( data );
            data := nil;
        end;
    end;

    procedure MZero (p: univ Ptr; size: longint);
    begin
        MFill( p, size, 0 );
    end;

    procedure MFill (p: univ Ptr; size: longint; val: integer);
        var
            i: UInt32;
    begin
        Assert( size >= 0 );
        if CheckPointer(p) then begin
            if size > 0 then begin { since i is unsigned, size-1 must be >= 0 }
                for i := 0 to size - 1 do begin
                    AddPtrLong(p, i)^ := SignedByte(val);
                end;
            end;
        end;
    end;

    procedure MFillLong (p: univ Ptr; size: longint; val: longint);
{ Ptr and size must be long alligned }
        type
            longPtr = ^longint;
        var
            i: longint;
    begin
        Assert( size >= 0 );
        if CheckPointer(p) then begin
            Assert( (band(ord4(p), 3) = 0) & (band(size, 3) = 0) );
            i := longint(p);
            while size > 3 do begin
                longPtr(i)^ := val;
                i := i + 4;
                size := size - 4;
            end;
        end;
    end;

    procedure LockHigh ( data: univ Handle );
    begin
        if CheckHandle( data ) then begin
            MoveHHi( data );
            HLock( data );
        end;
    end;

    procedure HLockState ( data: univ Handle; var state: SignedByte );
    begin
        if CheckHandle( data ) then begin
            state := HGetState(data);
            HLock(data);
        end;
    end;

    procedure HUnlockState ( data: univ Handle; var state: SignedByte );
    begin
        if CheckHandle( data ) then begin
            state := HGetState(data);
            HUnlock(data);
        end;
    end;

    procedure HRestoreState( data: univ Handle; state: SignedByte );
    begin
        if CheckHandle( data ) then begin
            HSetState( data, state );
        end;
    end;

    procedure MHLock( data: univ Handle );
    begin
        if CheckHandle( data ) then begin
            HLock( data );
        end;
    end;

    procedure MHUnlock( data: univ Handle );
    begin
        if CheckHandle( data ) then begin
            HUnlock( data );
        end;
    end;

    procedure MHPurge( data: univ Handle );
    begin
        if CheckHandle( data ) then begin
            HPurge( data );
        end;
    end;

    procedure MHNoPurge( data: univ Handle );
    begin
        if CheckHandle( data ) then begin
            HNoPurge( data );
        end;
    end;

    function MGetHandleSize( data: univ Handle ): longint;
    begin
        MGetHandleSize := 0;
        if CheckHandle( data ) then begin
            MGetHandleSize := GetHandleSize( data );
        end;
    end;

    function MGetPtrSize( data: univ Ptr ): longint;
    begin
        MGetPtrSize := 0;
        if CheckPtr( data ) then begin
            MGetPtrSize := GetPtrSize( data );
        end;
    end;

    function MMungerFind( data: Handle; offset: longint; ptr1: univ Ptr; len1: longint ): longint;
    begin
        if CheckHandle( data ) then begin
            Assert( (len1 > 0) & (0 <= offset) & (offset <= MGetHandleSize( data ) ) );
            MMungerFind := Munger(data, offset, ptr1, len1, nil, 0);
        end else begin
            MMungerFind := -1;
        end;
    end;

    function MMungerFindString( data: Handle; offset: longint; const s: string ): longint;
    begin
        MMungerFindString := MMungerFind( data, offset, @s[1], length(s) );
    end;

    function MMungerInsert( data: Handle; offset: longint; ptr2: univ Ptr; len2: longint ): OSErr;
        var
            junk_long: longint;
    begin
        if CheckHandle( data ) then begin
            Assert( (len2 >= 0) & (0 <= offset) & (offset <= MGetHandleSize( data ) ) );
            junk_long := Munger(data, offset, nil, 0, ptr2, len2);
            MMungerInsert := MemError;
        end else begin
            MMungerInsert := -1;
        end;
    end;

    function MMungerInsertString( data: Handle; offset: longint; const s: string ): OSErr;
    begin
        MMungerInsertString := MMungerInsert( data, offset, @s[1], length(s) );
    end;

    procedure MMungerDelete( data: Handle; offset: longint; len1: longint);
        var
            junk_long: longint;
    begin
        if CheckHandle( data ) then begin
            Assert( (len1 >= 0) & (0 <= offset) & (offset + len1 <= MGetHandleSize( data ) ) );
            junk_long := Munger(data, offset, nil, len1, @junk_long, 0);
        end;
    end;

    function MAppendToHandle( data: univ Handle; p: univ Ptr; len: longint ): OSErr;
    begin
        Assert( (len >= 0) );
        MAppendToHandle := -9987;
        if CheckHandle( data ) & CheckPointer( p ) then begin
            MAppendToHandle := PtrAndHand( p, data, len );
        end;
    end;


end.